home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / cal-french.el.z / cal-french.el
Encoding:
Text File  |  1998-10-28  |  10.4 KB  |  245 lines
  1. ;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
  2.  
  3. ;; Copyright (C) 1988, 1989, 1992, 1994, 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
  6. ;; Keywords: calendar
  7. ;; Human-Keywords: French Revolutionary calendar, calendar, diary
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; This collection of functions implements the features of calendar.el and
  29. ;; diary.el that deal with the French Revolutionary calendar.
  30.  
  31. ;; Technical details of the French Revolutionary calendar can be found in
  32. ;; ``Calendrical Calculations, Part II: Three Historical Calendars'' by
  33. ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, Software--Practice and
  34. ;; Experience, Volume 23, Number 4 (April, 1993), pages 383-404.
  35.  
  36. ;; Comments, corrections, and improvements should be sent to
  37. ;;  Edward M. Reingold               Department of Computer Science
  38. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  39. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  40. ;;                                   Urbana, Illinois 61801
  41.  
  42. ;;; Code:
  43.  
  44. (require 'calendar)
  45.  
  46. (defvar french-calendar-accents
  47.   (and (char-table-p standard-display-table)
  48.        (equal (aref standard-display-table 161) [161]))
  49.   "True if diacritical marks are available.")
  50.  
  51. (defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  52.   "Absolute date of start of French Revolutionary calendar = September 22, 1792.")
  53.  
  54. (defconst french-calendar-month-name-array
  55.   (if french-calendar-accents
  56.       ["VendΘmiaire" "Brumaire" "Frimaire" "Niv⌠se" "Pluvi⌠se" "Vent⌠se"
  57.        "Germinal" "FlorΘal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
  58.     ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  59.      "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]))
  60.  
  61. (defconst french-calendar-day-name-array
  62.   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  63.    "Octidi" "Nonidi" "Decadi"])
  64.  
  65. (defconst french-calendar-special-days-array
  66.   (if french-calendar-accents
  67.       ["de la Vertu" "du Genie" "du Labour" "de la Raison"
  68.        "de la RΘcompense" "de la RΘvolution"]
  69.     ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Re'compense"
  70.      "de la Re'volution"]))
  71.  
  72. (defun french-calendar-leap-year-p (year)
  73.   "True if YEAR is a leap year on the French Revolutionary calendar.
  74. For Gregorian years 1793 to 1805, the years of actual operation of the
  75. calendar, uses historical practice based on equinoxes is followed (years 3, 7,
  76. and 11 were leap years; 15 and 20 would have been leap years).  For later
  77. years uses the proposed rule of Romme (never adopted)--leap years fall every
  78. four years except century years not divisible 400 and century years that are
  79. multiples of 4000."
  80.   (or (memq year '(3 7 11));; Actual practice--based on equinoxes
  81.       (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
  82.       (and (> year 20)     ;; Romme's proposal--never adopted
  83.            (zerop (% year 4))
  84.            (not (memq (% year 400) '(100 200 300)))
  85.            (not (zerop (% year 4000))))))
  86.  
  87. (defun french-calendar-last-day-of-month (month year)
  88.   "Return last day of MONTH, YEAR on the French Revolutionary calendar.
  89. The 13th month is not really a month, but the 5 (6 in leap years) day period of
  90. `sansculottides' at the end of the year."
  91.   (if (< month 13)
  92.       30
  93.     (if (french-calendar-leap-year-p year)
  94.         6
  95.       5)))
  96.  
  97. (defun calendar-absolute-from-french (date)
  98.   "Compute absolute date from French Revolutionary date DATE.
  99. The absolute date is the number of days elapsed since the (imaginary)
  100. Gregorian date Sunday, December 31, 1 BC."
  101.   (let ((month (extract-calendar-month date))
  102.         (day (extract-calendar-day date))
  103.         (year (extract-calendar-year date)))
  104.     (+ (* 365 (1- year));; Days in prior years
  105.        ;; Leap days in prior years
  106.        (if (< year 20)
  107.            (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
  108.          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
  109.          (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
  110.             (- (/ (1- year) 100))
  111.             (/ (1- year) 400)
  112.             (- (/ (1- year) 4000))))
  113.        (* 30 (1- month));; Days in prior months this year
  114.        day;; Days so far this month
  115.        (1- french-calendar-epoch))));; Days before start of calendar
  116.  
  117. (defun calendar-french-from-absolute (date)
  118.   "Compute the French Revolutionary equivalent for absolute date DATE.
  119. The result is a list of the form (MONTH DAY YEAR).
  120. The absolute date is the number of days elapsed since the
  121. \(imaginary) Gregorian date Sunday, December 31, 1 BC."
  122.   (if (< date french-calendar-epoch)
  123.       (list 0 0 0);; pre-French Revolutionary date
  124.     (let* ((approx              ;; Approximation from below.
  125.             (/ (- date french-calendar-epoch) 366))
  126.            (year                ;; Search forward from the approximation.
  127.             (+ approx
  128.                (calendar-sum y approx
  129.                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
  130.                  1)))
  131.            (month               ;; Search forward from Vendemiaire.
  132.             (1+ (calendar-sum m 1
  133.                   (> date
  134.                      (calendar-absolute-from-french
  135.                       (list m
  136.                             (french-calendar-last-day-of-month m year)
  137.                             year)))
  138.                   1)))
  139.            (day                   ;; Calculate the day by subtraction.
  140.             (- date
  141.                (1- (calendar-absolute-from-french (list month 1 year))))))
  142.     (list month day year))))
  143.  
  144. (defun calendar-french-date-string (&optional date)
  145.   "String of French Revolutionary date of Gregorian DATE.
  146. Returns the empty string if DATE is pre-French Revolutionary.
  147. Defaults to today's date if DATE is not given."
  148.   (let* ((french-date (calendar-french-from-absolute
  149.                        (calendar-absolute-from-gregorian
  150.                         (or date (calendar-current-date)))))
  151.          (y (extract-calendar-year french-date))
  152.          (m (extract-calendar-month french-date))
  153.          (d (extract-calendar-day french-date)))
  154.     (cond
  155.      ((< y 1) "")
  156.      ((= m 13) (format (if french-calendar-accents
  157.                            "Jour %s de l'AnnΘe %d de la RΘvolution"
  158.                          "Jour %s de l'Anne'e %d de la Re'volution")
  159.                        (aref french-calendar-special-days-array (1- d))
  160.                        y))
  161.      (t (format
  162.          (if french-calendar-accents
  163.              "DΘcade %s, %s de %s de l'AnnΘe %d de la RΘvolution"
  164.            "De'cade %s, %s de %s de l'Anne'e %d de la Re'volution")
  165.          (make-string (1+ (/ (1- d) 10)) ?I)
  166.          (aref french-calendar-day-name-array (% (1- d) 10))
  167.          (aref french-calendar-month-name-array (1- m))
  168.          y)))))
  169.  
  170. (defun calendar-print-french-date ()
  171.   "Show the French Revolutionary calendar equivalent of the selected date."
  172.   (interactive)
  173.   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
  174.     (if (string-equal f "")
  175.         (message "Date is pre-French Revolution")
  176.       (message f))))
  177.  
  178. (defun calendar-goto-french-date (date &optional noecho)
  179.   "Move cursor to French Revolutionary date DATE.
  180. Echo French Revolutionary date unless NOECHO is t."
  181.   (interactive
  182.    (let* ((year (calendar-read
  183.                  (if french-calendar-accents
  184.                      "AnnΘe de la RΘvolution (>0): "
  185.                    "Anne'e de la Re'volution (>0): ")
  186.                  '(lambda (x) (> x 0))
  187.                  (int-to-string
  188.                   (extract-calendar-year
  189.                    (calendar-french-from-absolute
  190.                     (calendar-absolute-from-gregorian
  191.                      (calendar-current-date)))))))
  192.           (month-list
  193.            (mapcar 'list
  194.                    (append french-calendar-month-name-array
  195.                            (if (french-calendar-leap-year-p year)
  196.                                (mapcar
  197.                                 '(lambda (x) (concat "Jour " x))
  198.                                 french-calendar-special-days-array)
  199.                              (reverse
  200.                               (cdr;; we don't want rev. day in a non-leap yr.
  201.                                (reverse
  202.                                 (mapcar
  203.                                  '(lambda (x) (concat "Jour " x))
  204.                                  french-calendar-special-days-array))))))))
  205.           (completion-ignore-case t)
  206.           (month (cdr (assoc
  207.                        (capitalize
  208.                         (completing-read
  209.                          "Mois ou Sansculottide: "
  210.                          month-list
  211.                          nil t))
  212.                        (calendar-make-alist
  213.                         month-list
  214.                         1
  215.                         '(lambda (x) (capitalize (car x)))))))
  216.           (decade (if (> month 12)
  217.                       1
  218.                     (calendar-read
  219.                      (if french-calendar-accents
  220.                          "DΘcade (1-3): "
  221.                        "De'cade (1-3): ")
  222.                      '(lambda (x) (memq x '(1 2 3))))))
  223.           (day (if (> month 12)
  224.                    (- month 12)
  225.                  (calendar-read
  226.                   "Jour (1-10): "
  227.                   '(lambda (x) (and (<= 1 x) (<= x 10))))))
  228.           (month (if (> month 12) 13 month))
  229.           (day (+ day (* 10 (1- decade)))))
  230.      (list (list month day year))))
  231.   (calendar-goto-date (calendar-gregorian-from-absolute
  232.                        (calendar-absolute-from-french date)))
  233.   (or noecho (calendar-print-french-date)))
  234.  
  235. (defun diary-french-date ()
  236.   "French calendar equivalent of date diary entry."
  237.   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
  238.     (if (string-equal f "")
  239.         "Date is pre-French Revolution"
  240.       f)))
  241.  
  242. (provide 'cal-french)
  243.  
  244. ;;; cal-french.el ends here
  245.